// System Unit
// Modular Support

(*************)
(* Interface *)
(*************)
{$IFDEF Include_Modules_Header}

 Type
  PUnitTypeInfo = ^TUnitTypeInfo;
  TUnitTypeInfo = Record
   TypeCount: Cardinal;
   TypeTables: Pointer; {PPointer} { Pointer in this table is PPTypeInfo, except when it's not; if the value is 1,
                                     then it's a "unit boundary" marker, indicating that following types are in
                                     the next unit along in the TPackageTypeInfo.UnitNames unit name list sequence. }
   NameCount: Cardinal;
   UnitNames: PANSIChar; {ShortString} { Concatenation of Pascal strings, one for each unit }
  END;
  // Note: Apparently the unit names are only affiliated with the TypeInfo, not the parent ModuleInfo,
  //        which means that it cannot be used to identify unit name in initialization/finalization.

{$POINTERMATH ON}
  PUnitEntry = ^TUnitEntry;
  TUnitEntry = Packed Record
   Init, FInit: TProc;
  END; // 8B
{$POINTERMATH OFF}

  PModuleInfo = ^TModuleInfo;
  TModuleInfo = Record
   UnitCount: Cardinal; { Number of entries in UnitEntries array; always > 0 }
   UnitEntries: {Array [0..UnitCount-1] of} PUnitEntry;
   TypeInfo: TUnitTypeInfo;
  END;

 Type
  { Each package exports a '@GetPackageInfoTable' which can be used to retrieve
    the table which contains compiler generated information about the package DLL }
  GetPackageInfoTable = Function: PModuleInfo;

 Var
  IsConsole: Boolean = False;   { True main instance is a Delphi console application [Compiler Magic]}

 // These fields should be immutable
 Function MainInstance: NativeUInt;
 Function IsLibrary: Boolean;

 Type
  PLibModule = ^TLibModule;
  TLibModule = Record
   Next: PLibModule;
   Instance: NativeUInt;
   ModuleInfo: PModuleInfo;
   RTLEx: Pointer;
  END;

 // WARNING: Thread-unsafe! Must be called serially
 // (Note that these function are normally called in Main/DllMain
 //  which are called serially, so nothing special is needed)
 Type RTLProc_ModuleProc = Procedure(Const LibModule: PLibModule);
 Var ModuleInit: RTLProc_ModuleProc = NIL;
 Var ModuleFInit: RTLProc_ModuleProc = NIL;

 // WARNING: Thread-unsafe! Must be called serially
 // (Note that these function are normally called in Main/DllMain
 //  which are called serially, so nothing special is needed)
 Type RTLProc_ModuleReg = Procedure(Const LibModule: PLibModule);
 Var RegisterModule: RTLProc_ModuleReg = NIL;
 Var UnregisterModule: RTLProc_ModuleReg = NIL;

 // WARNING: Thread-unsafe! Must be called serially
 // TODO - RWLock
 Type RTLProc_FindModule = Function(Const Instance: NativeUInt): PLibModule;
 Var FindModule: RTLProc_FindModule = NIL;

 //==================
 // RTL Extensions
 //==================
 Type
  TRTLEx_Modular = Record
   ModuleInit: RTLProc_ModuleProc;
   ModuleFInit: RTLProc_ModuleProc;
   RegisterModule: RTLProc_ModuleReg;
   UnregisterModule: RTLProc_ModuleReg;
   FindModule: RTLProc_FindModule;
  END;

 Procedure RTLExtend_Modular(Var Ex: TRTLEx_Modular);

{$ENDIF Include_Modules_Header}
(******************)
(* Implementation *)
(******************)
{$IFDEF Include_Modules_Implement}

 ResourceString
  _RTL_ResStr_ModularUnitInit  = 'Initializing units';
  _RTL_ResStr_ModularUnitFInit = 'Finalizing units';
  _RTL_ResStr_NoLibModule      = 'No module registered with handle $$$$$$$$';

 Var
  _INT_MainInstance: NativeUInt = 0; { Handle of the main(.EXE) HInstance }
  _INT_IsLibrary: Boolean = True;    { True IF module is a DLL }
  _INT_InitProgress: Cardinal = 0;

 Function MainInstance: NativeUInt;
  BEGIN
   Result:= _INT_MainInstance;
  END;

 Function IsLibrary: Boolean;
  BEGIN
   Result:= _INT_IsLibrary;
  END;

 Procedure _INT_FinalizeUnits(Const ModuleInfo: TModuleInfo; InitCount: Cardinal);
  Var UnitEntry: PUnitEntry;
  BEGIN
   UnitEntry:= ModuleInfo.UnitEntries;

   Inc(_INT_InitProgress);
   While InitCount > 0 do
    BEGIN
     Dec(InitCount);
     With UnitEntry[InitCount] do
      Try
       IF Assigned(@FInit) then FInit;
      Except
       _INT_LogExceptionResContext(@_RTL_ResStr_ModularUnitFInit);
      END;
    END;
   Dec(_INT_InitProgress);
  END;

 Procedure _INT_InitUnits(Const ModuleInfo: TModuleInfo);
  Var
   Count: Cardinal;
   UnitEntry: PUnitEntry;
   SavedError: _INT_RTLErrorRec;
  BEGIN
   UnitEntry:= ModuleInfo.UnitEntries;

   Count:= 0;
   Inc(_INT_InitProgress);
   Try
    While Count < ModuleInfo.UnitCount do
     BEGIN
      With UnitEntry[Count] do
       IF Assigned(@Init) then Init;
      Inc(Count);
     END;
   Except
    SavedError:= _INT_RTLError;
    _INT_LogExceptionResContext(@_RTL_ResStr_ModularUnitInit);
    _INT_FinalizeUnits(ModuleInfo, Count + 1);
    Dec(_INT_InitProgress);

    _INT_RTLError:= SavedError;
    Raise;
   END;
   Dec(_INT_InitProgress);
  END;

 Procedure _RTL_ModuleInit(Const LibModule: PLibModule);
  BEGIN
   Try
    _INT_InitUnits(LibModule.ModuleInfo^);
   Except
    LibModule.ModuleInfo:= NIL;
    Raise;
   END;
  END;

 Procedure _RTL_ModuleFInit(Const LibModule: PLibModule);
  BEGIN
   IF Assigned(LibModule.ModuleInfo)
   then
    BEGIN
     _INT_FinalizeUnits(LibModule.ModuleInfo^, LibModule.ModuleInfo.UnitCount);
     LibModule.ModuleInfo:= NIL;
    END;
  END;

 Var
  _INT_ModuleRoot: PLibModule = NIL;

 Procedure _RTL_RegisterModule(Const LibModule: PLibModule);
  BEGIN
   LibModule.Next := _INT_ModuleRoot;
   _INT_ModuleRoot:= LibModule;
  END;

 Procedure _RTL_UnregisterModule(Const LibModule: PLibModule);
  Procedure _LOC_LogNoModule(Instance: NativeUInt);
   Var
    ErrMsg: Array [0..RTL_ResStr_MsgLen] of Char;
    MsgLen: Cardinal;
   BEGIN
    MsgLen:= LoadResStringFx(@_RTL_ResStr_NoLibModule, ErrMsg, RTL_ResStr_MsgLen+1);
    System.RTL_CardinalToHex8(Instance, @ErrMsg[MsgLen-8]);
    System.Log(llWarn, ErrMsg);
   END;

  Var CurModule: PLibModule;
  BEGIN
   CurModule:= _INT_ModuleRoot;
   IF LibModule = CurModule
   then _INT_ModuleRoot:= LibModule.Next
   else // Find module in chain
    BEGIN
     While Assigned(CurModule) do
      IF CurModule.Next <> LibModule
      then CurModule:= CurModule.Next
      else // Found
       BEGIN
        CurModule.Next:= LibModule.Next;
        Break;
       END;
     // Log a warning if module not found
     IF NOT Assigned(CurModule)
     then _LOC_LogNoModule(LibModule.Instance);
    END;
  END;

 Function _RTL_FindModule(Const Instance: NativeUInt): PLibModule;
  BEGIN
   Result:= _INT_ModuleRoot;
   While Assigned(Result) do
    IF Instance <> Result.Instance
    then Result:= Result.Next
    else Break;
  END;

 //==================
 // RTL Extensions
 //==================

 Procedure RTLExtend_Modular(Var Ex: TRTLEx_Modular);
  BEGIN
   _INT_RTL_DoEx(@ModuleInit, @Ex.ModuleInit);
   _INT_RTL_DoEx(@ModuleFInit, @Ex.ModuleFInit);
   _INT_RTL_DoEx(@RegisterModule, @Ex.RegisterModule);
   _INT_RTL_DoEx(@UnregisterModule, @Ex.UnregisterModule);
   _INT_RTL_DoEx(@FindModule, @Ex.FindModule);
  END;

 Procedure _INT_Modular_Init;
  BEGIN
   ModuleInit:= _RTL_ModuleInit;
   ModuleFInit:= _RTL_ModuleFInit;
   RegisterModule:= _RTL_RegisterModule;
   UnregisterModule:= _RTL_UnregisterModule;
   FindModule:= _RTL_FindModule;
  END;

{$ENDIF Include_Modules_Implement}
(******************)
(* Initialization *)
(******************)
{$IFDEF Include_Modules_Initialize}
{$ENDIF Include_Modules_Initialize}
(****************)
(* Finalization *)
(****************)
{$IFDEF Include_Modules_Finalize}
{$ENDIF Include_Modules_Finalize}
